home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / xlisp16.arc / XLEVAL.C < prev    next >
Text File  |  1985-12-10  |  8KB  |  362 lines
  1. /* xleval - xlisp evaluator */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern int xlsample;
  10. extern NODE ***xlstack,***xlstkbase,*xlenv;
  11. extern NODE *s_lambda,*s_macro;
  12. extern NODE *k_optional,*k_rest,*k_aux;
  13. extern NODE *s_evalhook,*s_applyhook;
  14. extern NODE *s_unbound;
  15. extern NODE *s_stdout;
  16.  
  17. /* trace variables */
  18. extern NODE **trace_stack;
  19. extern int xltrace;
  20.  
  21. /* forward declarations */
  22. FORWARD NODE *xlxeval();
  23. FORWARD NODE *evalhook();
  24. FORWARD NODE *evform();
  25. FORWARD NODE *evfun();
  26.  
  27. /* xleval - evaluate an xlisp expression (checking for *evalhook*) */
  28. NODE *xleval(expr)
  29.   NODE *expr;
  30. {
  31.     /* check for control codes */
  32.     if (--xlsample <= 0) {
  33.     xlsample = SAMPLE;
  34.     oscheck();
  35.     }
  36.  
  37.     /* check for *evalhook* */
  38.     if (getvalue(s_evalhook))
  39.     return (evalhook(expr));
  40.  
  41.     /* add trace entry */
  42.     if (++xltrace < TDEPTH)
  43.     trace_stack[xltrace] = expr;
  44.  
  45.     /* check type of value */
  46.     if (consp(expr))
  47.     expr = evform(expr);
  48.     else if (symbolp(expr))
  49.     expr = xlgetvalue(expr);
  50.  
  51.     /* remove trace entry */
  52.     --xltrace;
  53.  
  54.     /* return the value */
  55.     return (expr);
  56. }
  57.  
  58. /* xlxeval - evaluate an xlisp expression (bypassing *evalhook*) */
  59. NODE *xlxeval(expr)
  60.   NODE *expr;
  61. {
  62.     /* check type of value */
  63.     if (consp(expr))
  64.     expr = evform(expr);
  65.     else if (symbolp(expr))
  66.     expr = xlgetvalue(expr);
  67.  
  68.     /* return the value */
  69.     return (expr);
  70. }
  71.  
  72. /* xlapply - apply a function to a list of arguments */
  73. NODE *xlapply(fun,args)
  74.   NODE *fun,*args;
  75. {
  76.     NODE *env,*val;
  77.  
  78.     /* check for a null function */
  79.     if (fun == NIL)
  80.     xlfail("bad function");
  81.  
  82.     /* evaluate the function */
  83.     if (subrp(fun))
  84.     val = (*getsubr(fun))(args);
  85.     else if (consp(fun)) {
  86.     if (consp(car(fun))) {
  87.         env = cdr(fun);
  88.         fun = car(fun);
  89.     }
  90.     else
  91.         env = xlenv;
  92.     if (car(fun) != s_lambda)
  93.         xlfail("bad function type");
  94.     val = evfun(fun,args,env);
  95.     }
  96.     else
  97.     xlfail("bad function");
  98.  
  99.     /* return the result value */
  100.     return (val);
  101. }
  102.  
  103. /* evform - evaluate a form */
  104. LOCAL NODE *evform(expr)
  105.   NODE *expr;
  106. {
  107.     NODE ***oldstk,*fun,*args,*env,*val,*type;
  108.  
  109.     /* create a stack frame */
  110.     oldstk = xlsave(&fun,&args,NULL);
  111.  
  112.     /* get the function and the argument list */
  113.     fun = car(expr);
  114.     args = cdr(expr);
  115.  
  116.     /* evaluate the first expression */
  117.     if ((fun = xleval(fun)) == NIL)
  118.     xlfail("bad function");
  119.  
  120.     /* evaluate the function */
  121.     if (subrp(fun) || fsubrp(fun)) {
  122.     if (subrp(fun))
  123.         args = xlevlist(args);
  124.     val = (*getsubr(fun))(args);
  125.     }
  126.     else if (consp(fun)) {
  127.     if (consp(car(fun))) {
  128.         env = cdr(fun);
  129.         fun = car(fun);
  130.     }
  131.     else
  132.         env = xlenv;
  133.     if ((type = car(fun)) == s_lambda) {
  134.         args = xlevlist(args);
  135.         val = evfun(fun,args,env);
  136.     }
  137.     else if (type == s_macro) {
  138.         args = evfun(fun,args,env);
  139.         val = xleval(args);
  140.     }
  141.     else
  142.         xlfail("bad function type");
  143.     }
  144.     else if (objectp(fun))
  145.     val = xlsend(fun,args);
  146.     else
  147.     xlfail("bad function");
  148.  
  149.     /* restore the previous stack frame */
  150.     xlstack = oldstk;
  151.  
  152.     /* return the result value */
  153.     return (val);
  154. }
  155.  
  156. /* evalhook - call the evalhook function */
  157. LOCAL NODE *evalhook(expr)
  158.   NODE *expr;
  159. {
  160.     NODE ***oldstk,*ehook,*ahook,*args,*val;
  161.  
  162.     /* create a new stack frame */
  163.     oldstk = xlsave(&ehook,&ahook,&args,NULL);
  164.  
  165.     /* make an argument list */
  166.     args = consa(expr);
  167.     rplacd(args,consa(xlenv));
  168.  
  169.     /* rebind the hook functions to nil */
  170.     ehook = getvalue(s_evalhook);
  171.     setvalue(s_evalhook,NIL);
  172.     ahook = getvalue(s_applyhook);
  173.     setvalue(s_applyhook,NIL);
  174.  
  175.     /* call the hook function */
  176.     val = xlapply(ehook,args);
  177.  
  178.     /* unbind the symbols */
  179.     setvalue(s_evalhook,ehook);
  180.     setvalue(s_applyhook,ahook);
  181.  
  182.     /* restore the previous stack frame */
  183.     xlstack = oldstk;
  184.  
  185.     /* return the value */
  186.     return (val);
  187. }
  188.  
  189. /* xlevlist - evaluate a list of arguments */
  190. NODE *xlevlist(args)
  191.   NODE *args;
  192. {
  193.     NODE ***oldstk,*src,*dst,*new,*last,*val;
  194.  
  195.     /* create a stack frame */
  196.     oldstk = xlsave(&src,&dst,NULL);
  197.  
  198.     /* initialize */
  199.     src = args;
  200.  
  201.     /* evaluate each argument */
  202.     for (val = NIL; src; src = cdr(src)) {
  203.  
  204.     /* check this entry */
  205.     if (!consp(src))
  206.         xlfail("bad argument list");
  207.  
  208.     /* allocate a new list entry */
  209.     new = consa(NIL);
  210.     if (val)
  211.         rplacd(last,new);
  212.     else
  213.         val = dst = new;
  214.     rplaca(new,xleval(car(src)));
  215.     last = new;
  216.     }
  217.  
  218.     /* restore the previous stack frame */
  219.     xlstack = oldstk;
  220.  
  221.     /* return the new list */
  222.     return (val);
  223. }
  224.  
  225. /* xlunbound - signal an unbound variable error */
  226. xlunbound(sym)
  227.   NODE *sym;
  228. {
  229.     xlcerror("try evaluating symbol again","unbound variable",sym);
  230. }
  231.  
  232. /* evfun - evaluate a function */
  233. LOCAL NODE *evfun(fun,args,env)
  234.   NODE *fun,*args,*env;
  235. {
  236.     NODE ***oldstk,*oldenv,*newenv,*cptr,*fargs,*val;
  237.  
  238.     /* create a stack frame */
  239.     oldstk = xlsave(&oldenv,&newenv,&cptr,NULL);
  240.  
  241.     /* skip the function type */
  242.     if ((fun = cdr(fun)) == NIL || !consp(fun))
  243.     xlfail("bad function definition");
  244.  
  245.     /* get the formal argument list */
  246.     if ((fargs = car(fun)) && !consp(fargs))
  247.     xlfail("bad formal argument list");
  248.  
  249.     /* create a new environment frame */
  250.     newenv = xlframe(env);
  251.     oldenv = xlenv;
  252.  
  253.     /* bind the formal parameters */
  254.     xlabind(fargs,args,newenv);
  255.     xlenv = newenv;
  256.  
  257.     /* execute the code */
  258.     for (cptr = cdr(fun); cptr; )
  259.     val = xlevarg(&cptr);
  260.  
  261.     /* restore the environment */
  262.     xlenv = oldenv;
  263.  
  264.     /* restore the previous stack frame */
  265.     xlstack = oldstk;
  266.  
  267.     /* return the result value */
  268.     return (val);
  269. }
  270.  
  271. /* xlabind - bind the arguments for a function */
  272. xlabind(fargs,aargs,env)
  273.   NODE *fargs,*aargs,*env;
  274. {
  275.     NODE *arg;
  276.  
  277.     /* evaluate and bind each required argument */
  278.     while (consp(fargs) && !iskeyword(arg = car(fargs)) && consp(aargs)) {
  279.  
  280.     /* bind the formal variable to the argument value */
  281.     xlbind(arg,car(aargs),env);
  282.  
  283.     /* move the argument list pointers ahead */
  284.     fargs = cdr(fargs);
  285.     aargs = cdr(aargs);
  286.     }
  287.  
  288.     /* check for the '&optional' keyword */
  289.     if (consp(fargs) && car(fargs) == k_optional) {
  290.     fargs = cdr(fargs);
  291.  
  292.     /* bind the arguments that were supplied */
  293.     while (consp(fargs) && !iskeyword(arg = car(fargs)) && consp(aargs)) {
  294.  
  295.         /* bind the formal variable to the argument value */
  296.         xlbind(arg,car(aargs),env);
  297.  
  298.         /* move the argument list pointers ahead */
  299.         fargs = cdr(fargs);
  300.         aargs = cdr(aargs);
  301.     }
  302.  
  303.     /* bind the rest to nil */
  304.     while (consp(fargs) && !iskeyword(arg = car(fargs))) {
  305.  
  306.         /* bind the formal variable to nil */
  307.         xlbind(arg,NIL,env);
  308.  
  309.         /* move the argument list pointer ahead */
  310.         fargs = cdr(fargs);
  311.     }
  312.     }
  313.  
  314.     /* check for the '&rest' keyword */
  315.     if (consp(fargs) && car(fargs) == k_rest) {
  316.     fargs = cdr(fargs);
  317.     if (consp(fargs) && (arg = car(fargs)) && !iskeyword(arg))
  318.         xlbind(arg,aargs,env);
  319.     else
  320.         xlfail("symbol missing after &rest");
  321.     fargs = cdr(fargs);
  322.     aargs = NIL;
  323.     }
  324.  
  325.     /* check for the '&aux' keyword */
  326.     if (consp(fargs) && car(fargs) == k_aux)
  327.     while ((fargs = cdr(fargs)) != NIL && consp(fargs))
  328.         xlbind(car(fargs),NIL,env);
  329.  
  330.     /* make sure the correct number of arguments were supplied */
  331.     if (fargs != aargs)
  332.     xlfail(fargs ? "too few arguments" : "too many arguments");
  333. }
  334.  
  335. /* iskeyword - check to see if a symbol is a keyword */
  336. LOCAL int iskeyword(sym)
  337.   NODE *sym;
  338. {
  339.     return (sym == k_optional || sym == k_rest || sym == k_aux);
  340. }
  341.  
  342. /* xlsave - save nodes on the stack */
  343. NODE ***xlsave(n)
  344.   NODE **n;
  345. {
  346.     NODE ***oldstk,***nptr;
  347.  
  348.     /* save the old stack pointer */
  349.     oldstk = xlstack;
  350.  
  351.     /* save each node pointer */
  352.     for (nptr = &n; *nptr; nptr++) {
  353.     if (xlstack <= xlstkbase)
  354.         xlabort("evaluation stack overflow");
  355.     *--xlstack = *nptr;
  356.     **nptr = NIL;
  357.     }
  358.  
  359.     /* return the old stack pointer */
  360.     return (oldstk);
  361. }
  362.